home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue43 / delay / HVHeaps.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1999-01-27  |  2.7 KB  |  113 lines
  1. unit HVHeaps;
  2. //
  3. // Simple wrapper classes around the Win32 Heap functions.
  4. // Written by Hallvard Vassbotn (hallvard@falcon.no), January 1999
  5. //
  6. interface
  7.  
  8. uses
  9.   Windows;
  10.  
  11. type
  12.   // The TPrivateHeap class gives basic memory allocation capability
  13.   // The benefit of using this class instead of the native GetMem
  14.   // and FreeMem routines, is that the memory pages used will
  15.   // be seperate from other allocations. This gives reduced
  16.   // fragmentation.
  17.   TPrivateHeap = class(TObject)
  18.   private
  19.     FHandle: THandle;
  20.     FAllocationFlags: DWORD;
  21.     function GetHandle: THandle;
  22.   public
  23.     destructor Destroy; override;
  24.     procedure GetMem(var P{: pointer}; Size: DWORD); virtual;
  25.     procedure FreeMem(P: pointer);
  26.     function SizeOfMem(P: pointer): DWORD;
  27.     property Handle: THandle read GetHandle;
  28.     property AllocationFlags: DWORD read FAllocationFlags write FAllocationFlags;
  29.   end;
  30.  
  31.   // The Code Heap adds the feature of allocating readable/writable
  32.   // and executable memory blocks. This allows us to have safe
  33.   // run-time generated code while not wasting as much memory
  34.   // as calls to VirtualAlloc would have caused, while avoiding
  35.   // the pitfalls of changing the protection flags of blocks
  36.   // allocated with GetMem.
  37.   TCodeHeap = class(TPrivateHeap)
  38.   public
  39.     procedure GetMem(var P{: pointer}; Size: DWORD); override;
  40.   end;
  41.  
  42. implementation
  43.  
  44. uses
  45.   SysUtils,
  46.   D2Support;
  47.  
  48. function Win32Handle(Handle: THandle): THandle;
  49. begin
  50.   if Handle = 0 then
  51.     RaiseLastWin32Error;
  52.   Result := Handle;
  53. end;
  54.  
  55. function Win32Pointer(P: Pointer): Pointer;
  56. begin
  57.   if P = nil then
  58.     RaiseLastWin32Error;
  59.   Result := P;
  60. end;
  61.  
  62. { TPrivateHeap }
  63.  
  64. destructor TPrivateHeap.Destroy;
  65. begin
  66.   if FHandle <> 0 then
  67.   begin
  68.     Win32Check(Windows.HeapDestroy(FHandle));
  69.     FHandle := 0;
  70.   end;
  71.   inherited Destroy;
  72. end;
  73.  
  74. procedure TPrivateHeap.FreeMem(P: pointer);
  75. begin
  76.   Win32Check(Windows.HeapFree(Handle, 0, P));
  77. end;
  78.  
  79. function TPrivateHeap.GetHandle: THandle;
  80. begin
  81.   if FHandle = 0 then
  82.     FHandle := Win32Handle(Windows.HeapCreate(0, 0, 0));
  83.   Result := FHandle;
  84. end;
  85.  
  86. procedure TPrivateHeap.GetMem(var P{: pointer}; Size: DWORD);
  87. begin
  88.   Pointer(P) := Win32Pointer(Windows.HeapAlloc(Handle, AllocationFlags, Size));
  89. end;
  90.  
  91. function TPrivateHeap.SizeOfMem(P: pointer): DWORD;
  92. begin
  93.   Result := Windows.HeapSize(Handle, 0, P);
  94.   // HeapSize does not set GetLastError, but returns $FFFFFFFF if it fails
  95.   if Result = $FFFFFFFF then
  96.     Result := 0;
  97. end;
  98.  
  99. { TCodeHeap }
  100.  
  101. procedure TCodeHeap.GetMem(var P{: pointer}; Size: DWORD);
  102. var
  103.   Dummy: DWORD;
  104. begin
  105.   inherited GetMem(P, Size);
  106.   Win32Check(Windows.VirtualProtect(Pointer(P), Size, PAGE_EXECUTE_READWRITE, @Dummy));
  107. end;
  108.  
  109. end.
  110.  
  111.  
  112.  
  113.